home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Resource Library: Multimedia
/
Resource Library: Multimedia.iso
/
space
/
software
/
src
/
vaxdriv.for
< prev
Wrap
Text File
|
1993-06-12
|
11KB
|
273 lines
PROGRAM VAXDRIV
C********************************************************************
C THIS IS A SAMPLE PROGRAM WHICH READS AND DECOMPRESSES VOYAGER
C IMAGES AND WRITES THEM OUT IN PDS LABELLED FORMAT. IT ALSO
C MODIFIES THE PDS LABELS TO REFLECT THE CONVERSION FROM VARIABLE
C TO FIXED RECORD FORMAT. IT USES THE SUBROUTINES IN DECOMP.FOR
C TO PERFORM THE DECOMPRESSION. TWO VERSIONS OF THE DRIVER EXIST,
C ONE WHICH RUNS ON THE IBM PC USING MICROSOFT FORTRAN, VERSION 4.XX,
C AND ONE WHICH RUNS UNDER VAX/VMS FORTRAN. THE TWO VERSIONS ARE
C IDENTICAL EXCEPT FOR THE FILE OPEN STATEMENTS AND VARIABLE
C LENGTH RECORD I/O (READ STATEMENTS).
C
C_HIST
C AUG89 FIXED LENGTH OF OUTPUT SFDU.
C JUL88 PC AND VAX VERSIONS BY MIKE MARTIN 1988/07/30, WITH
C ASSISTANCE FROM ROGER BOWEN, WHO CODED THE FIRST PC VERSIONS
C OF THESE ROUTINES.
C
C INPUTS - INPUT FILE TO BE DECOMPRESSED.
C
C OUTPUTS - OUTPUT FILE CONTAINING DECOMPRESSED IMAGE.
C
C TO COMPILE AND LINK UNDER MICROSOFT FORTRAN USE THE COMMAND:
C
C FL /FPi PCDRIV.FOR DECOMP.FOR
C
C TO COMPILE AND LINK USING VAX/VMS FORTRAN USE THE COMMANDS:
C
C FOR VAXDRIV,DECOMP
C LINK VAXDRIV,DECOMP
C_END
C_VARS
CHARACTER NAME*80, INAME*80, LABSTRING*80, OUTSTRING*2508,
1 IBUF(2048), OBUF(2508),TEMPSTRING*80
CHARACTER CR,LF,BLANK
INTEGER*2 TOTAL_BYTES,LINE,I,J,NLEN
INTEGER*4 HIST(512),HISTIN(209)
INTEGER*4 LEN,NS
EQUIVALENCE (IBUF,LABSTRING,HISTIN), (OBUF,OUTSTRING)
C********************************************************************
C
C INITIALIZE SOME CONSTANTS
C
C********************************************************************
CR = CHAR(13)
LF = CHAR(10)
BLANK = CHAR(32)
NS = 836
C********************************************************************
C
C GET INPUT AND OUTPUT FILE NAMES AND OPEN THE FILES
C
C********************************************************************
WRITE (*,1000)
1000 FORMAT(' ENTER NAME OF FILE TO BE DECOMPRESSED: ')
1020 FORMAT(A)
READ (*,1020) INAME
WRITE (*,1010)
1010 FORMAT(' ENTER NAME OF UNCOMPRESSED OUTPUT FILE:')
READ (*,1020) NAME
OPEN (10,FILE=INAME,FORM='FORMATTED',STATUS='OLD',READONLY)
OPEN (11,FILE=NAME, FORM='UNFORMATTED',STATUS='NEW',
1 RECORDTYPE='FIXED',RECORDSIZE=209)
C********************************************************************
C
C READ AND PROCESS THE COMPRESSED FILE LABELS.
C
C ALL THE LABELS ARE CONCATINATED INTO AN ARRAY, TO ALLOW THE 50-ODD
C LABEL LINES TO BE WRITTEN OUT AS 3-FIXED-LENGTH RECORDS ON THE VAX.
C
C********************************************************************
TOTAL_BYTES = 0
101 FORMAT(Q,A)
100 READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
C********************************************************************
C
C EDIT THE PDS LABELS WHICH HAVE TO BE CHANGED.
C
C********************************************************************
C CHANGE THE LENGTH FIELD OF THE SFDU LABEL
C********************************************************************
I = INDEX(LABSTRING,'NJPL1I00PDS1')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:12) // '00673796' //
1 LABSTRING(21:NLEN)
OUTSTRING = TEMPSTRING(1:NLEN) // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C CHANGE THE RECORD TYPE FROM VARIABLE TO FIXED
C********************************************************************
I = INDEX(LABSTRING,'RECORD_TYPE')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // 'FIXED_LENGTH'
NLEN = NLEN-3
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C CHANGE THE FILE RECORD COUNT TO REFLECT THE FIXED STRUCTURE
C********************************************************************
I = INDEX(LABSTRING,'FILE_RECORDS')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // '806'
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C CHANGE THE COUNT OF LABEL RECORDS TO 3
C********************************************************************
I = INDEX(LABSTRING,'LABEL_RECORDS')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // '3'
NLEN = NLEN -1
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C CHANGE THE LOCATION POINTER OF THE HISTOGRAM TO RECORD 4
C********************************************************************
I = INDEX(LABSTRING,'^IMAGE_HISTOGRAM')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // '4'
NLEN = NLEN -1
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C DELETE THE ENCODING HISTOGRAM LOCATION POINTER
C********************************************************************
I = INDEX(LABSTRING,'^ENCODING_HISTOGRAM')
IF (I .EQ. 1) GOTO 100
C********************************************************************
C CHANGE THE LOCATION POINTER OF THE ENGINEERING TABLE TO RECORD 6
C********************************************************************
I = INDEX(LABSTRING,'^ENGINEERING_TABLE')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // '6'
NLEN = NLEN -1
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C CHANGE THE LOCATION POINTER OF THE IMAGE TO RECORD 7
C********************************************************************
I = INDEX(LABSTRING,'^IMAGE')
IF (I .EQ. 1) THEN
TEMPSTRING = LABSTRING(1:35) // '7'
NLEN = NLEN -1
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // TEMPSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
GOTO 100
ENDIF
C********************************************************************
C DELETE THE ENCODING HISTOGRAM OBJECT DEFINITION
C********************************************************************
I = INDEX(LABSTRING,
1 'OBJECT = ENCODING_')
IF (I .EQ. 1) THEN
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
GOTO 100
ENDIF
C********************************************************************
C DELETE THE ENCODING TYPE KEYWORD IN THE IMAGE OBJECT DEFINITION
C********************************************************************
I = INDEX(LABSTRING,' ENCODING')
IF (I .EQ. 1) GOTO 100
C********************************************************************
C IF WE GET HERE JUST WRITE OUT THE LABEL
C********************************************************************
OUTSTRING = OUTSTRING(1:TOTAL_BYTES) // LABSTRING(1:NLEN)
1 // CR // LF
TOTAL_BYTES = TOTAL_BYTES + NLEN + 2
I= INDEX(LABSTRING,'END')
IF (I .EQ. 1 .AND. NLEN .EQ. 3) GOTO 300
GOTO 100
C********************************************************************
C PAD OUT LABELS TO MULTIPLE OF 836
C********************************************************************
300 DO 310 I=TOTAL_BYTES+1,2508
310 OBUF(I) = BLANK
C********************************************************************
C NOW WRITE OUT THE LABEL RECORDS IN 3-WRITES, FILLING OUT THE THIRD
C RECORD TO 836 BYTES WITH BLANKS.
C********************************************************************
WRITE(11) (OBUF(I), I= 1, 836)
WRITE(11) (OBUF(I), I= 837, 1672)
WRITE(11) (OBUF(I), I=1673, 2508)
C********************************************************************
C
C READ AND WRITE THE IMAGE HISTOGRAM AS TWO RECORDS, FILLING OUT THE
C SECOND RECORD TO 836 BYTES WITH BLANKS.
C
C********************************************************************
DO 320 J=1,2
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
IF (NLEN .EQ. 836) WRITE(11) (IBUF(I), I=1, NLEN)
320 CONTINUE
DO 330 I=NLEN+1,836
330 IBUF(I) = BLANK
WRITE(11) (IBUF(I), I=1, 836)
C********************************************************************
C
C READ THE ENCODING HISTOGRAM, AND LOAD THE HIST ARRAY FOR USE BY
C THE DECOMPRESSION SUBROUTINES.
C
C********************************************************************
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
DO 340 I=1,209
340 HIST(I) = HISTIN(I)
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
DO 350 I=1,209
350 HIST(I+209) = HISTIN(I)
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
DO 360 I=1,93
360 HIST(I+418) = HISTIN(I)
C********************************************************************
C
C READ AND WRITE THE ENGINEERING SUMMARY AS ONE RECORD, FILLING OUT
C THE RECORD TO 836 BYTES WITH BLANKS.
C
C********************************************************************
READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
DO 370 I=NLEN+1,836
370 IBUF(I) = BLANK
WRITE(11) (IBUF(I), I=1, 836)
C********************************************************************
C
C INITIALIZE THE DECOMPRESSION.
C
C********************************************************************
WRITE(*,*) 'INITIALIZING DECOMPRESSION ROUTINE...'
CALL DECMPINIT(HIST)
C********************************************************************
C
C PERFORM THE DECOMPRESSION.
C
C********************************************************************
WRITE(*,*) 'DECOMPRESSING DATA...'
LINE=0
400 READ(10,101,END=500) NLEN, LABSTRING(1:NLEN)
LINE = LINE + 1
LEN = NLEN
CALL DECOMPRESS(IBUF, OBUF, LEN, NS)
WRITE(11) (OBUF(I), I=1, NS)
J = MOD(LINE,100)
IF (J .EQ. 0) WRITE (*,'(I5,A6)') LINE,' LINES'
IF (LINE .EQ. 800) GOTO 500
GO TO 400
C********************************************************************
C
C DONE. CLOSE FILES AND GET OUT OF HERE.
C
C********************************************************************
500 CLOSE(10)
CLOSE(11)
END